perm filename FONTS.SAV[JLG,SYS] blob
sn#812565 filedate 1986-03-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 BEGOF("FONTS")
C00005 00003 the following procedure has been changed to do (hopefully) the
C00007 00004 IFK PASSONE THENK
C00009 00005 IFK PASSONE THENK
C00011 00006 IFK PASSONE THENK
C00014 00007 IFK PASSONE THENK
C00016 00008 IFK PASSONE THENK
C00017 00009 IFK PASSONE THENK
C00019 00010 IFK PASSONE THENK
C00020 00011 IFK PASSONE OR PASSTWO THENK
C00024 00012 IFK PASSONE OR PASSTWO THENK
C00037 00013 IFK PASSONE THENK
C00038 00014 IFK PASSONE OR PASSTWO THENK
C00044 00015 IFK PASSONE THENK
C00046 00016 IFK PASSONE THENK
C00047 00017 IFK PASSONE THENK
C00050 00018 IFK PASSONE THENK
C00052 00019 IFK PASSONE THENK
C00053 00020 IFK PASSONE THENK
C00055 00021 IFK PASSONE THENK
C00056 00022 IFK PASSONE THENK
C00057 ENDMK
C⊗;
BEGOF("FONTS")
IFC PASSONE THENC
COMMENT
*** Variations at Different Sites ***
Font file formats differ at each site. Default device parameters
(mostly specified in PUBDFS.SAI and COMDFS.SAI, but partly in
SETDEVICEPARAMETERS) also differ. Character width checking is only
enabled at some sites (XLENGTH).
***
This module handles device characteristics, fonts, pichars, and
raster measurements. Some of it is shared by passes one and two, but
most of it is for pass one only.
The trickiest thing is the font numbering system. There are three
numbering systems: the one in the FONT declaration (one character 0-9
A-F), the one used to index arrays (0-16), and the one expected by
the device (varies). Yechh!
;
ENDC
comment conditional changed by jlj 4/22/83;
IFCR PARCVER or sailver THENC
DEFINE MAXNEQUIVS = [100] ;
INTEGER NEQUIVS ;
OWN STRING ARRAY EQUIV[1:MAXNEQUIVS, 2:4] ;
ENDC
PROCEDURES
comment the following procedure has been changed to do (hopefully) the
same thing but in a way SAIL will understand. changed by jlj 5/10/83
IFK PASSONE OR PASSTWO THENK
PRIVATE SIMPLE INTEGER PROCEDURE BYTEIN(INTEGER CHAN) $"#
BEGIN TES 4/16/75
INTEGER X
START!CODE
PUSH '17,CHAN
PUSHJ '17,CVJFN
PBIN
MOVEM 2,X
END
RETURN(X)
END "BYTEIN"
ENDC
;
IFK PASSONE OR PASSTWO THENK
PRIVATE SIMPLE INTEGER PROCEDURE BYTEIN(INTEGER CHAN) ;$"#
BEGIN
INTEGER X;
BufferCount ← BufferCount - 1 ; comment # words remaining in the buffer ;
if BufferCount < 0 then begin comment new record needs to be read in ;
ARRYIN(CHAN, RecBuf[0], 128) ; comment get 128 words, dump in RecBuf ;
BufferCount ← 128 * 2 - 1 ; comment new count (2 bytes per word) ;
RecordNumber ← RecordNumber+1 ; comment update # records read in ;
BufPointer ← Point(16, RecBuf[0], -1) ;
comment byte pointer to the 128 words just read in ;
end ;
RETURN(X ← ILDB(BufPointer)) ; comment 16 bit byte needed ;
END "BYTEIN" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE FONTS! ;$"#
BEGIN "FONTS!"
WCW ← WHATIS(CW) ; COMMENT original font ;
THISFONT ← OLDFONT ← DEFAULTFONT ;
FSFONT ← DEFAULTFONT ; TES 11/29/73 ;
FSVERSION ← 0 ; TES 3/29/75 PARC ONLY ;
LOFONT ← 99 ; HIFONT ← 0 ; TES 8/24/74 ;
ODDLEFTBORDER ← ODDLEFTBORDERDEFAULT ; EVENLEFTBORDER ← EVENLEFTBORDERDEFAULT ; TES 8/21/74 ;
BOTTOMBORDER ← BOTTOMBORDERDEFAULT ; TOPBORDER ← TOPBORDERDEFAULT ; TES 1/26/75 ;
SETDEVICEPARAMETERS(ABS(DEVICE)) ; TES 8/24/74 ;
ifc parcver thenc
fwfile←"FONTS.WIDTHS"; DCS 7/78;
endc
comment added by jlj 4/26/83;
ifc sailver thenc
fwfile ← "FONTS.WID[1,3]"
endc
END "FONTS!" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE DDEVICE ;$"#
BEGIN PASS ;
RKJ: 19-AUG-74 ADDED ON BELOW;
IF DEVICE GEQ 0 AND ON THEN COMMENT IF <0, WAS SET BY /SWITCH, WHICH TAKES PRECEDENCE ;
BEGIN
INTEGER OLDDEVICE ; OLDDEVICE ← DEVICE ; TES 7/21/75 ;
IFCR PARCVER THENC PARCMIC ENDC
IF ITS(PRE) THEN DEVICE←MIC
ELSE IF ITS(TTY) THEN DEVICE←TTY
ELSE IF ITS(LPT) THEN DEVICE←LPT
ELSE IF ITS(XGP) THEN DEVICE←XGP
ELSE BEGIN WARN("=","No such device: "&THISWD) ; PASS ; RETURN END ;
IF ABS(DEVICE) NEQ ABS(OLDDEVICE) AND PLACEDALREADY THEN
WARN("=", "Shouldn't change DEVICE in mid-stream") ; tes 7/21/75 ;
SETDEVICEPARAMETERS(ABS(DEVICE)) ; TES 8/24/74 ;
END ;
PASS ;
END "DDEVICE" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE DFONT(BOOLEAN SELECT) ;$"#
BEGIN "DFONT"
INTEGER F;
PASS;
comment conditional changed by jlj 4/22/83;
IFC PARCVER or sailver THENC
IF ITS(EQUIVALENCE) THEN TES 10/21/74 ;
WHILE TRUE DO
BEGIN
IF NEQUIVS<MAXNEQUIVS THEN NEQUIVS←NEQUIVS+1
ELSE WARN(NULL,"Exceeded limit of " & CVS(MAXNEQUIVS) & " FONT EQUIVALENCEs") ;
FOR F ← 2, XGP, MIC DO
BEGIN
PASS ;
EQUIV[NEQUIVS,F] ← E(NULL, NULL) ;
IF NOT ITSCH(<,>) THEN DONE ;
END ;
IF NOT ITSCH(<,>) THEN RETURN ;
END ;
ENDC
IF LENGTH(THISWD)=1 AND THISTYPE GEQ 0 AND (F←RFONT(THISWD)) GEQ 0 THEN PASS
ELSE F ← RFONT(E(NULL,NULL)) ; TES 11/29/73 ;
IF F<0 THEN
BEGIN WARN("=",<"Illegal font '"&F&"'">); RETURN END;
IF SELECT THEN SELECTFONT(F) TES 1/22/74 ADDED OPTIONAL XGP FILENAME ;
ELSE READFONT(F,E(NULL,NULL), IF ITSCH(<,>) THEN PASS&E(NULL,NULL) ELSE NULL);
END "DFONT";
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE DPICHAR ;$"#
BEGIN TES 11/29/73 ;
INTEGER KEY, IX, F, N ; STRING S ;
INPICHAR ← TRUE ;
S ← NULL ;
PASS ;
KEY ←E(NULL,NULL) ;
IF ITSCH(<(>) THEN
BEGIN COMMENT TURN ON ;
PASS ;
DO S ← S & E(NULL,NULL) UNTIL ITSCH(<)>) ;
PASS ;
IF ITS(WIDTH) THEN
BEGIN PASS ;
IF ITS(OF) THEN BEGIN PASS ; F←'177; N←CVD(E(NULL,NULL)) END
ELSE BEGIN F←CVD(E(NULL,NULL)); N←F MOD '177; F←F DIV '177 END
END
ELSE BEGIN F←'177 ; N ← SP END ;
S ← F & N & S ;
END
ELSE S ← NULL ; COMMENT TURN OFF ;
IX ← PUSHI(PIWDS,PITYPE) ;
PIKEY(IX) ← KEY ; PIVAL(IX) ← PUSHS(1, PICHAR[KEY]) ;
PICHAR[KEY] ← S ;
INPICHAR ← FALSE ;
END "DPICHAR" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE DPSPOOL ;$"#
BEGIN TES 3/29/75 ;
STRING PROPNAME ;
PASS ;
PROPNAME ← THISWD ;
PASS ;
IF ON AND ABS(DEVICE) = MIC THEN
INITIALLIST ← INITIALLIST & PROPNAME & SP & DEFN(FALSE, TRUE-7, 0, 0)[1 TO ∞-1] & CRLF
COMMENT DROP LAST CHAR OFF DEFN VALUE -- EXTRA SPACE! ;
ELSE DEFN(FALSE, FALSE, 0, 0) ;
END "DPSPOOL" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE STRING PROCEDURE FONTEQUIV(STRING ABBREV) ;$"#
BEGIN "FONTEQUIV" TES 10/21/74 CALLED BY OPENTOREAD ;
IFCR PARCVER THENC
INTEGER I, D ; STRING ALTNAME ;
IF ABS(DEVICE) LEQ 2 THEN RETURN(NULL) ;
ABBREV ← CAPITALIZE(ABBREV) ;
FOR D ← 2, XGP+MIC-ABS(DEVICE) DO
FOR I ← NEQUIVS STEP -1 UNTIL 1 DO
IF EQU(EQUIV[I,D], ABBREV) THEN
BEGIN
ALTNAME ← EQUIV[I, ABS(DEVICE)] ;
IF NULSTR(ALTNAME) THEN CONTINUE ;
IF ALTNAME = "*" THEN
BEGIN
LOPP(ALTNAME) ;
IF NOT SWDBACK THEN OUTSTR(CRLF) ; SWDBACK ← TRUE ;
OUTSTR("Closest FONT to " & ABBREV & " is " & ALTNAME & CRLF) ;
END ;
IF EQU(ALTNAME, ABBREV) THEN CONTINUE ;
RETURN(ALTNAME) ;
END ;
RETURN(NULL) ;
ENDC
END "FONTEQUIV" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE STRING PROCEDURE MASH(STRING S) ;$"#
BEGIN COMMENT TES 8/14/74 UNPACK 7-BIT BYES TO 64-EXCESS 4-BIT BYTES;
INTEGER C ; STRING Q ;
Q ← NULL ;
WHILE FULSTR(S) DO
BEGIN
C ← LOP(S) ;
Q ← Q & ((C LSH -4)+64) & ((C LAND '17)+64) ;
END ;
RETURN(Q) ;
END ;
ENDC
IFK PASSONE OR PASSTWO THENK
PUBLIC PROCEDURE TFMPERUSE(INTEGER WHICH, CHAN, FILESIZE) ;$"#
BEGIN "TFMPERUSE"
INTEGER ARRAY BUF[0:FILESIZE-1];
INTEGER BUFPTR, X, INDEX, MULTIPLIER;
INTEGER LENH, BC, EC, NW, NH, ND, FACE;
INTEGER NI, NL, NK, NE, NP;
REAL DEZSIZ, DUMMY, SPACE;
MULTIPLIER ← (2540 / 72.27); COMMENT POINTS TO MICAS;
ARRYIN(CHAN, Buf[0], FILESIZE) ; comment READ IN THE WHOLE FILE;
BUFPTR ← Point(16, Buf[0], -1) ;
X←ILDB(BUFPTR); LENH←ILDB(BUFPTR); BC ← ILDB(BUFPTR); EC ← ILDB(BUFPTR);
NW ← ILDB(BUFPTR); NH ← ILDB(BUFPTR); ND ← ILDB(BUFPTR);
NI ← ILDB(BUFPTR); NL ← ILDB(BUFPTR); NK ← ILDB(BUFPTR);
NE ← ILDB(BUFPTR); NP ← ILDB(BUFPTR);
BEGIN "CHARINFO"
INTEGER ARRAY WIDTHS[BC:EC]; COMMENT INDICES FOR EACH CHARACTER;
REAL ARRAY WIDS[0:NW-1]; COMMENT WIDTH VALUES, IN FRACTION OF DESSIZ UNITS;
REAL MAXHEIGHT, MAXDEPTH;
INDEX ← 6; COMMENT ALWAYS HAVE 6 WORDS IN BEGINNING;
DEZSIZ ← ((BUF[7] ASH -4) / (2↑20)); COMMENT DESIGN SIZE IS ALWAYS 8TH WORD;
FACE ← ((BUF[23] ASH -4) LAND '777); COMMENT FACE IS ALWAYS 24TH WORD;
INDEX ← INDEX + LENH;
IF EC > 127 THEN EC ← 127; COMMENT CW CAN ONLY HANDLE EC ≤ 127 FOR NOW;
FOR I ← BC THRU EC DO
WIDTHS[I] ← ((BUF[INDEX + I - BC] LSH -28) LAND '377);
INDEX ← INDEX + EC - BC + 1; COMMENT LEAVE INDEX AT START OF WID INFO;
FOR I ← 0 THRU NW-1 DO
WIDS[I] ← ((BUF[INDEX + I] ASH -4) / (2↑20)) * DEZSIZ * MULTIPLIER;
MAXHEIGHT ← ((BUF[INDEX + NW + NH - 1] ASH -4) / (2↑20)) * DEZSIZ * MULTIPLIER;
MAXDEPTH ← ((BUF[INDEX + NW + NH + ND -1] ASH -4) / (2↑20)) * DEZSIZ * MULTIPLIER;
SPACE ← ((BUF[INDEX+NW+NH+ND+NI+NL+NK+NE + 1] ASH -4)/(2↑20))*DEZSIZ*MULTIPLIER;
IF WHICH = DEFAULTFONT
THEN BASELINE ← MAXDEPTH;
FNTINF[WHICH]← MAXHEIGHT + MAXDEPTH;
IFC PASSTWO THENC
YBelowBase[WHICH] ← MAXDEPTH;
YAboveBase[WHICH] ← MAXHEIGHT;
FONTSIZE ← FNTSIZE[WHICH] ← FNTINF[WHICH];
FNTBC[WHICH] ← BC;
FNTEC[WHICH] ← EC;
DUMMY ← MULTIPLIER * DEZSIZ;
FNTSIZ[WHICH] ← -(DUMMY + 0.5);
FNTFACE[WHICH] ← FACE;
ENDC
FOR I ← BC THRU EC DO
CW[I] ← WIDS[WIDTHS[I]];
IF EC > 31 THEN
CW[32] ← SPACE + 0.5;
END; "CHARINFO"
END; "TFMPERUSE"
ENDC;
IFK PASSONE OR PASSTWO THENK
PUBLIC SIMPLE PROCEDURE FONTTYPE(STRING N; REFERENCE STRING FAM;
REFERENCE INTEGER PT,MOD) ;$"#
BEGIN
comment code changed by jlj 5/9/83 ;
IFC SAILVER THENC
begin "PFT" dcs 7/78;
integer state,k; string m;
m←n;
state←0;
mod←0; pt←0; fam←null;
while length(m) do begin
k←lop(m);
if "a" leq k leq "z" then k←k-"a"+"A";
if "0" leq k leq "9" then
begin
if state=0 then state←1
end else begin
if state=1 then state←2
end;
if state=0 then fam←fam&k;
if state=1 then pt←pt*10+k-"0";
if state=2 then begin
if k="B" then mod←mod lor 2;
if k="I" then mod←mod lor 1;
end;
end;
if state=0 then Outstr("Illegal font spec. "&n&crlf);
end "PFT";
ENDC;
END;
ENDC
IFK PASSONE OR PASSTWO THENK
PUBLIC SIMPLE PROCEDURE PERUSEFONT(INTEGER WHICH, CHAN; STRING NAM;
REFERENCE BOOLEAN GOTIT) ;$"#
BEGIN
INTEGER I, K, YBelow;
IFCR ITSVER THENC PJ 5/28/74 ; PJ 3/20/75 TO CATCH EOF ;
WORDIN(CHAN);
FNTINF[WHICH]←WORDIN(CHAN);
IF WHICH=DEFAULTFONT THEN BASELINE←LDB(POINT(9,FNTINF[WHICH],17));
FNTINF[WHICH]←LDB(POINT(18,FNTINF[WHICH],35)); comment HEIGHT;
WHILE NOT EOF DO
IF (WORDIN(CHAN) LAND 1) AND DUMMY NEQ -1 THEN
BEGIN
DUMMY←LDB(POINT(18,DUMMY←WORDIN(CHAN),35));
CW[DUMMY]←LDB(POINT(18,CW[DUMMY]←WORDIN(CHAN),35));
END
ENDC
IFCR CMUXGP THENC RKJ: MODIFIED 7-nov-74;
WORDIN(CHAN); COMMENT KST ID;
FNTINF[WHICH]←WORDIN(CHAN); COMMENT RKJ 10-10-73;
IF (DUMMY←WORDIN(CHAN)) NEQ 2 THEN
BEGIN "FORMAT 1"
LABEL whattakludge;
IF DUMMY LAND 1 THEN GO whattakludge;
WHILE NOT EOF DO
IF (WORDIN(CHAN) LAND 1) THEN
whattakludge: BEGIN DUMMY←WORDIN(CHAN); CW[DUMMY]←WORDIN(CHAN) END
END "FORMAT 1"
ELSE
BEGIN "FORMAT 2"
IF WHICH=DEFAULTFONT THEN BASELINE←WORDIN(CHAN) ELSE WORDIN(CHAN);
ARRYIN(CHAN,CW[0],6); COMMENT UNUSED WORDS;
ARRYIN(CHAN,CW[0],128); COMMENT XWD INCR,WIDTH;
FOR I←0 THRU 127 DO CW[I]←CW[I] LSH -18;
END "FORMAT 2";
ENDC
IFCR SAILVER THENC
comment conditional added by jlj 5/9/83 ;
if DEVICE ≠ MIC then begin
ARRYIN(CHAN,CW[0],128);
FOR I ← 0 THRU 127 DO
CW[I] ← IF CW[I] THEN CW[I] LSH -18 ELSE -1 ; BH 11/5/74;
WORDIN(CHAN); FNTINF[WHICH]←WORDIN(CHAN);
WORDIN(CHAN);
IF WHICH=DEFAULTFONT THEN BASELINE←WORDIN(CHAN);
end else begin
comment this module changed by jlj 5/9/83 ;
comment this is the new code for the case DEVICE = MIC. ;
INTEGER I, K ;
comment changed by jlj 5/10/83 ;
comment Hopefully, the next instruction has been taken care of in BYTEIN ;
comment SFBSZ(CHAN, 16) ;
IF ABS(DEVICE)=MIC THEN
begin "PF" dcs 7/78;
integer i,w,t,bsiz,famno,pt,face,sl,len,ffn,bbc,siz,rota,pos,bc,ec,bpos;
real scale; string fam,sn;
FONTTYPE(nam, fam, pt, face);
bsiz←-1; famno←-1;
comment added by jlj 5/10/83. initialize variables for BYTEIN ;
BufferCount ← 0 ; comment # words remaining in the buffer ;
RecordNumber ← 0 ; comment # of the last record read ;
comment before the first call to BYTEIN,
BufPointer is undefined ;
do begin "readix"
w←bytein(chan);
t←w lsh -12; len←(w land '7777)-1;
if t=1 and famno=-1 then begin "famlook"
famno←bytein(chan);
for i←1 thru len-1 do begin
w←bytein(chan);
if i=1 then begin sl←(w div 256)-1; sn←w mod 256 end
else begin
if sl>0 then sn←sn&(w div 256);
if sl>1 then sn←sn&(w mod 256);
sl←sl-2;
end;
end;
if not equ(sn,fam) then famno←-1;
len←0;
end;
if t=4 then begin
ffn←bytein(chan);
bbc←bytein(chan);
siz←bytein(chan);
rota←bytein(chan);
pos←bytein(chan)*(256*256); pos←pos+bytein(chan);
i←bytein(chan); i←bytein(chan);
len←0;
if ffn=famno*256+face and rota=0 and
(abs(siz-((pt*2540) div 72))<2 or (bsiz=-1 and siz=0)) then begin
bsiz←siz;
bpos←pos;
bc←bbc div 256; ec←bbc mod 256;
IF EC > 127 THEN EC ← 127;
comment jlg the CW array has 127 for upper bound;
end;
end;
for i←1 thru len do bytein(chan);
end "readix" until t=0;
if famno=-1 or bsiz=-1 then
GOTIT ← FALSE
else begin "rdw"
INTEGER ByteSkip ; comment added by jlj 5/10/83 ;
GOTIT ← TRUE;
RecordNumber ← (((bpos+1) DIV 2) DIV 128) + 1 ;
USETI(chan, RecordNumber) ; comment select proper input record ;
ARRYIN(chan,RecBuf[0],128) ; comment read the record ;
ByteSkip ← (bpos + 1) - 256*(RecordNumber - 1) ;
comment the above counts the bytes to skip at the start of the record ;
BufferCount ← 128*2 - ByteSkip ;
BufPointer ← Point(16,RecBuf[0],-1) ;
START!CODE
MOVE 1,ByteSkip;
IBP 1,BufPointer;
MOVEM 1,BufPointer;
end;
comment now are ready to call BYTEIN to read the bpos+1th byte of the file ;
if bsiz=0 then scale←(2540*pt)/72000 COMMENT RELATIVE SIZE;
ELSE SCALE ← 1.0; COMMENT ABSOLUTE SIZE ENTRY;
T ← BYTEIN(CHAN); COMMENT Y OFFSET FOR FNT BNDING BOX;
YBelow ← ((T XOR '177777) + 1) * SCALE; COMMENT 2'S COMP;
IF WHICH=DEFAULTFONT THEN BASELINE ← YBelow;
T ← BYTEIN(CHAN); COMMENT X WIDTH FOR FONT BOUNDING BOX;
FNTINF[WHICH]←bytein(chan)*scale; Comment BOUNDING BOX Y height;
IFK PASSTWO THENK
YBelowBase[WHICH] ← YBelow;
YAboveBase[WHICH] ← FNTINF[WHICH] - YBelow;
FONTSIZE ← FNTSIZE[WHICH] ← FNTINF[WHICH];
FNTBC[WHICH] ← BC;
FNTEC[WHICH] ← EC;
FNTSIZ[WHICH] ← PT;
FNTFACE[WHICH] ← FACE;
ENDC
t←bytein(chan);
if (t land '100000) then
begin
t←bytein(chan)*scale;
for i←bc thru ec do CW[i]←t;
end
else
begin
for i←bc thru ec do
begin
t←bytein(chan);
if t neq '100000 then CW[i]←t*scale;
end;
end;
FNTNUMBER[WHICH] ← -1;
end "rdw";
end "PF"
end;
ENDC;
END "PERUSEFONT" ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE STRING PROCEDURE PICKFONT(INTEGER F) ;$"#
RETURN(FONTCHAR&"F"&(IF F<10 THEN (F+"0") ELSE (F+("A"-10))));
PUBLIC SIMPLE STRING PROCEDURE PICKVERSION(INTEGER V) ;$"#
TES 3/29/75 ;
RETURN(IFC PARCVER THENC IF ABS(DEVICE)=MIC THEN FONTCHAR&"V"&(IF V THEN CVSR(V) ELSE ALTMODE) ELSE ENDC NULL);
ENDC
IFK PASSONE OR PASSTWO THENK
PUBLIC PROCEDURE READFONT(INTEGER WHICH; STRING FILENAME, BFILENAME) ;$"#
IFC PASSONE THENC IF ON AND XCRIBL THEN ENDC
BEGIN "READFONT"
BOOLEAN PFOUNDIT, TFOUNDIT; COMMENT JLG PERUSEFONT, TFM, RESPECTIVELY;
INTEGER ARRAY FILEDATA[1:6];
INTEGER SAVCW, CHAN, FILSIZ;
INTEGER EOF, FLAG;
SAVCW ← WHATIS(CW);
IF FNTFIL[WHICH] = 0 THEN FNTFIL[WHICH] ← CREATE(0,127);
DUMMY ← FNTFIL[WHICH] ;
IF SAVCW=WCW AND WHICH=DEFAULTFONT THEN SAVCW←DUMMY;
MAKEBE(DUMMY,CW);
ifc parcver thenc ifc newmic thenc DCS 7/78;
if DEVICE=MIC then begin
CHAN←OPENTOREAD('14,"Font widths file",FWFILE,"","<FONTS>");
end else
endc endc
IFC SAILVER THENC
IF DEVICE = MIC THEN
BEGIN
IF (CHAN←GETCHAN)<0 THEN
IFC PASSONE THENC EARLYWARNING("NO CHANNELS ARE LEFT FOR INPUT!") ;
ELSEC PRINT("NO CHANNELS ARE LEFT FOR INPUT!"); ENDC
TFOUNDIT ← PFOUNDIT ← FALSE;
EOF ← 1 ;
FLAG ← 0;
OPEN(CHAN,"DSK",14, 2,0,150,BRC,EOF);
IF EOF ≠ 0 THEN PRINT("OPEN failed, device DSK not available.");
LOOKUP(CHAN,FILENAME & ".TFM[TFM,SYS]", FLAG);
FILEINFO(FILEDATA);
FILSIZ ← (-(FILEDATA[4] ROT 18));
IF FLAG = 0 THEN
BEGIN
TFOUNDIT ← TRUE;
TFMPERUSE(WHICH,CHAN,FILSIZ);
END
ELSE
BEGIN
IFC PASSONE THENC
CHAN ← OPENTOREAD('14, "Font widths file", FWFILE, "", "[1,3]");
ELSEC
EOF ← 1 ;
FLAG ← 0;
OPEN(CHAN,"DSK",14, 2,0,150,BRC,EOF);
IF EOF ≠ 0 THEN PRINT("OPEN failed, device DSK not available.");
LOOKUP(CHAN,"FONTS.WID[1,3]", FLAG);
ENDC
PERUSEFONT(WHICH, CHAN, FILENAME, PFOUNDIT) ;
END;
IF NOT(TFOUNDIT OR PFOUNDIT) THEN
PRINT(" *CANNOT FIND AN ENTRY FOR FONT ",FILENAME,"* ");
END;
ENDC;
IF DEVICE ≠ MIC then BEGIN
IFC PASSONE THENC
CHAN ← OPENTOREAD('14, "Font file ", FILENAME, FONTEXT, FONTPPN) ;
ELSEC
EOF ← 1 ;
FLAG ← 0;
OPEN(CHAN,"DSK",14, 2,0,150,BRC,EOF);
IF EOF ≠ 0 THEN PRINT("OPEN failed, device DSK not available.");
LOOKUP(CHAN,FILENAME, FLAG);
ENDC
PERUSEFONT(WHICH, CHAN, FILENAME, PFOUNDIT) ;
END;
IF NULSTR(BFILENAME) THEN TES Didn't specify special name for XGP driver ;
IFCR TENEX THENC
BEGIN STRING NAME, EXT, PPN ;
NAME←CVFIL(FILENAME,EXT,PPN) ;
BFILENAME ← NAME & EXT ;
END ;
ELSEC
BFILENAME ← FILENAME ;
ENDC
XFNTNAME[WHICH] ← BFILENAME ;
FNTNAME[WHICH] ← FILENAME ;
IFCR SAILVER THENC
BEGIN INTEGER NAME, EXT, PPN ;
COMMENT BH 12/13/74 TO FLUSH .FNT[XGP,SYS] FROM .XGP FILE ;
IFC PASSTWO THENC
DEFINE FONTPPN = ['704760637163], COMMENT [XGP,SYS];
FONTEXT = ['465664000000]; COMMENT FNT ;
ENDC
NAME←CVFIL(FILENAME,EXT,PPN) ;
IF EXT=FONTEXT THEN EXT←0 ;
IF PPN=FONTPPN THEN PPN←0 ;
CMDFILE ← CMDFILE & "/FONT#" & CVS(WHICH-1) & "=" &
UNCVFIL (0,NAME,EXT,PPN) ;
END
ENDC;
HIFONT ← WHICH MAX HIFONT ; LOFONT ← WHICH MIN LOFONT ; TES 8/24/74 ;
RELEASE(CHAN);
MAKEBE(SAVCW,CW);
END "READFONT";
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE INTEGER PROCEDURE RFONT(INTEGER F) ;$"#
RETURN( TES SUBROUTINIZED AND CASED 11/29/73 ;
IFCR SAILXGP THENC
IF "1" LEQ F LEQ "9" THEN F-"0"
ELSE IF "A" LEQ F LEQ "Z" THEN F-("A"-10)
ELSE IF "a" LEQ F LEQ "z" THEN F-("a"-10)
ELSE -1
ENDC
IFCR PARCVER THENC
IF ABS(DEVICE)=XGP THEN
IF "1" LEQ F LEQ "9" THEN F-"0"
ELSE -1
ELSE IF ABS(DEVICE)=MIC THEN
IF "0" LEQ F LEQ "9" THEN F-"0"
ELSE IF "A" LEQ F LEQ "F" THEN F-("A"-10)
ELSE IF "a" LEQ F LEQ "f" THEN F-("a"-10)
ELSE -1
ELSE 1
ENDC
IFCR CMUXGP THENC
IF "A" LEQ F LEQ "B" THEN F-("A"-10)
ELSE IF "a" LEQ F LEQ "b" THEN F-("a"-10)
ELSE IF "1" LEQ F LEQ "2" THEN F-"0"
ELSE -1
ENDC
) ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE SELECTFONT(INTEGER WHICH) ;$"#
IF ON THEN
BEGIN "SELECTFONT"
INTEGER F;
DBREAK;
IF NOT XCRIBL OR LAST<4 THEN RETURN;
F←(IF WHICH<10 THEN (WHICH+"0") ELSE (WHICH+("A"-10)));
IF FNTFIL[WHICH]=0 THEN BEGIN WARN("=",<"Unknown font '"& F & "'">);
RETURN END;
SWITCHFONT(WHICH) ; TES 11/14/73 SUBROUTINIZED ;
END "SELECTFONT";
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE SWITCHFONT(INTEGER WHICH) ;$"#
BEGIN TES 11/15/73 TO DO IT BY AREA ;
INTEGER NEWIX ;
IF AREAIXM AND FONTSIX(AREAIXM) < OLDIHED THEN
BEGIN TES FIRST CHANGE IN THIS BLOCK IN THIS AREA ;
NEWIX ← PUSHI(FONTWDS, FONTYPE) ;
AREAX(NEWIX) ← AREAIXM ;
OUTERX(NEWIX) ← FONTSIX(AREAIXM) ;
THISFONTX(NEWIX) ← THISFONT ;
OLDFONTX(NEWIX) ← OLDFONT ;
FONTSIX(AREAIXM) ← NEWIX ;
END ;
OLDFONT ← THISFONT;
IF THISFONT NEQ WHICH THEN
BEGIN
THISFONT ← WHICH;
WHICH ← FNTFIL[WHICH]; MAKEBE(WHICH,CW);
END ;
END ;
PUBLIC SIMPLE PROCEDURE SWVERSION(INTEGER WHICH) ;$"#
BEGIN TES 3/29/75 ;
INTEGER NEWIX ;
IF NOT ON OR ABS(DEVICE) NEQ MIC THEN RETURN ;
WHICH ← IF WHICH < 0 OR WHICH > '77777 THEN '77777 ELSE WHICH ;
IF WHICH = THISVERSION THEN RETURN ;
IF AREAIXM AND VERSIONSIX(AREAIXM) < OLDIHED THEN
BEGIN TES FIRST CHANGE IN THIS BLOCK IN THIS AREA ;
NEWIX ← PUSHI(VERSIONWDS, VERTYPE) ;
AREAX(NEWIX) ← AREAIXM ;
OUTERX(NEWIX) ← VERSIONSIX(AREAIXM) ;
THISVERSIONX(NEWIX) ← THISVERSION ;
OLDVERSIONX(NEWIX) ← OLDVERSION ;
VERSIONSIX(AREAIXM) ← NEWIX ;
END ;
OLDVERSION ← THISVERSION;
THISVERSION ← WHICH ;
IF NOT NOPGPH THEN
BEGIN
EMIT(NULL) ;
APPEND(PICKVERSION(THISVERSION)) ;
END ;
END ;
ENDC
IFK PASSONE THENK
PUBLIC SIMPLE PROCEDURE SETDEVICEPARAMETERS(INTEGER DEVICE) ;$"#
BEGIN TES 8/24/74 ;
STRING ABBREV, EQD ;
DEFINE GETS = [← CASE DEVICE-1 OF];
COMMENT DEVICES 1=LPT 2=TTY 3=MIC 4=XGP ;
COMMENT ----- ----- ----- ----- ;
CHARW GETS (1, 1, (VBPIMIC*8)/100, 16) ;
MINCHARW GETS (1, 1, 0, IFC SAILVER THENC 0 ELSEC 1 ENDC) ;
XCRIBL GETS (FALSE, FALSE, TRUE, TRUE) ;
VBPI GETS (6, 6, VBPIMIC, VBPIXGP) ;
HBPI GETS (10, 10, HBPIMIC, HBPIXGP) ;
MINLFTMAR GETS (0, 0, MICMINLFTMAR, XGPMINLFTMAR) ;
VUNDERLINE GETS (BAR,
IFC PARCVER THENC NULL ELSEC BAR ENDC,
BAR, BAR) ;
IFC CMUVER THENC
IF XCRIBL AND NULSTR(FNTNAME[1]) THEN
BEGIN
READFONT(DEFAULTFONT,"NGR25.KST[A730KS00]",NULL);
END ;
ENDC
END "SETDEVICEPARAMETERS" ;
ENDC
IFK PASSONE THENK
PUBLIC STRING SIMPLE PROCEDURE TRUNCATE(STRING STR; INTEGER LEN) ;$"#
BEGIN "TRUNCATE" COMMENT RETURN INITIAL SUBSTRING OF STR OF XLEN LEQ LEN ;
STRING S; INTEGER I,L;
S←STR; I←L←0;
WHILE FULSTR(S) DO
BEGIN
IF (L←L+CW[LOP(S)])>LEN THEN RETURN(STR[1 TO I]);
I←I+1;
END;
RETURN(STR);
END "TRUNCATE";
ENDC
IFK PASSONE THENK
PUBLIC INTEGER SIMPLE PROCEDURE XLENGTH(STRING CHARS) ;$"#
BEGIN "XL"
INTEGER COUNT,CH,W,MAXCHARW;
IF NOT XCRIBL THEN RETURN(0); COMMENT IF NOT IN XCRIBL MODE THEN WE DON'T NEED THIS VALUE;
IF NOT ON THEN RETURN(0) ; TES 10/20/74 ;
COUNT←0; MAXCHARW←XMAXIM; TES 8/24/74 ;
FNTUSED[THISFONT] ← TRUE ; TES 4/14/75 ;
WHILE FULSTR(CHARS) DO
IFCR SAILVER OR PARCVER THENC
BEGIN TES 8/14/74, HOW ABOUT CMU & ITS ? ;
IF MINCHARW LEQ (W← CW[ CH←LOP(CHARS) ]) LEQ MAXCHARW THEN
COUNT ← COUNT + W
ELSE WARN("Bad FONT char", <"The character '" & CVOS(CH) &
" has an unusual FONT width " & CVS(W) &
(IF NULSTR(FNTNAME[THISFONT]) THEN CRLF & "because you forgot to declare FONT "
ELSE " in " & FNTNAME[THISFONT] & " FONT ") &
PICKFONT(THISFONT)[3 TO 3]>) ;
END ;
ELSEC
COUNT ← COUNT + CW[LOP(CHARS)];
ENDC
RETURN (COUNT);
END;
ENDC
IFK PASSONE THENK
PUBLIC INTEGER SIMPLE PROCEDURE XSPLEN(INTEGER N) ;$"#
RETURN(N * CW[SP]);
ENDC
IFK PASSONE THENK
FINISHED
ENDOF("FONTS")
ENDC